home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / file-utils / backup-files.lisp next >
Encoding:
Text File  |  1992-09-02  |  2.3 KB  |  69 lines  |  [TEXT/CCL2]
  1. ;;; backup-files.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; Given the name of a source directory and the name of a destination
  12. ;;; directory, if the source directory and the containing directory
  13. ;;; of the destination directory exist, then create a copy of all
  14. ;;; source directory folders (recursively) and copy all files matching
  15. ;;; a pattern that are newer than the corresponding files in the destination
  16. ;;; directory (if they exist)
  17. ;;;
  18. ;;; USE:
  19. ;;;
  20. ;;; backup-files
  21. ;;;
  22. ;;; E.G: 
  23. ;;;       (backup-files "IDDI;" "HD105:Paul:IDDI-back:" "*.lisp")
  24. ;;;
  25. ;;; HISTORY:
  26. ;;;
  27. ;;; 4/20/92 Created.  - PM
  28. ;;;
  29.  
  30. (in-package :ccl)
  31.  
  32. (eval-when (:compile-toplevel :load-toplevel :execute)
  33.   (export '(backup-files) :ccl))
  34.  
  35.  
  36. (defun backup-files (source destination &optional (pattern "*"))
  37.   (when (and (probe-file source) (probe-file destination))
  38.     (format t "~%~%Backing up ~s~%" source)
  39.     (with-cursor *watch-cursor*
  40.       (backup-files-1 source destination pattern))) )
  41.  
  42.  
  43. (defun backup-files-1 (source destination pattern)
  44.   (let* ((dir-pattern (concatenate 'simple-string source "*"))
  45.          (dirs (directory dir-pattern :directories t :files nil))
  46.          (file-pattern (concatenate 'simple-string source pattern))
  47.          (files (directory file-pattern :directories nil :files t)))
  48.     (if (null (probe-file destination))
  49.       (create-file destination :if-exists nil))
  50.     (dolist (dir dirs)
  51.       (backup-files-1 (namestring dir)
  52.                       (add-last-folder-to-path dir destination)
  53.                       pattern))
  54.     (dolist (file files)
  55.       (let ((new-file (merge-pathnames destination file)))
  56.         (when (or (null (probe-file new-file))
  57.                   (> (file-write-date file) (file-write-date new-file)))
  58.           (format t "Writing file: ~s~%" new-file)
  59.           (copy-file file new-file :if-exists :overwrite)) )) ))
  60.  
  61.  
  62. (defun add-last-folder-to-path (src-path dest-path)
  63.   (let ((last-folder (first (last (pathname-directory 
  64.                                    (mac-directory-namestring src-path)))))
  65.         (mac-dest (mac-namestring dest-path)))
  66.     (concatenate 'simple-string mac-dest (string last-folder) ":") ))
  67.  
  68.  
  69. (provide :backup-files)